home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
drawer.zip
/
DRAWER.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-01-04
|
10KB
|
549 lines
{$L-,D-}
Program Drawer;
Uses
MSGraph, Shape, Canvas, CommWell,
ColorBar, Event, Dragger, Dialog, Crt;
const
MWIDTH = 60;
type
Handler = procedure( E : Event);
var
vc : _VideoConfig;
cx, cy : word;
CW : CommWell;
FCW : CommWell;
CB : ColorBar;
Can : Canvas;
MHandler : Handler;
ColorShape : GText;
Drag : Dragger;
BDrag : BDragger;
CurDrag : Dragger;
GlobalState : (Idling, Creating, Selecting, Moving, Sizing, Done);
GlobalShape : (None, Rect, FRect, Ell, FEll, Lin, Txt);
{$F+}
procedure HandleSelector( E : Event);
var
x1, y1, x2, y2 : word;
dx, dy : integer;
begin
if E.typ = LBUTTONDOWN then begin
CurDrag := BDrag;
if Can.PtInSelection(E.x, E.y) then begin
Can.GetRange( x1, y1, x2, y2);
if Can.OnHandle( E.x, E.y) then begin
{ we've got a size operation}
GlobalState := Sizing;
BDrag.Initialize( Size, x1, y1, x2, y2);
end
else begin
{ we've got a move operation }
GlobalState := Moving;
BDrag.Initialize( Move, x1, y1, x2, y2);
end;
end
else begin
GlobalState := Selecting;
Can.UnSelectAllObjects;
BDrag.Initialize( Size, E.x, E.y, E.x, E.y);
end;
CurDrag.StartDrag( E.x, E.y);
end
else if E.typ = LBUTTONUP then begin
BDrag.GetRange(x1, y1, x2, y2);
CurDrag.EndDrag( E.x, E.y );
if GlobalState=Moving then begin
dx := x2 - x1;
dy := y2 - y1;
Can.Move( dx, dy);
Can.Erase;
Can.Draw;
end
else if GlobalState=Sizing then begin
dx := x2 - x1;
dy := y2 - y1;
Can.Size( dx, dy );
Can.Erase;
Can.Draw;
end
else
{ must be selecting }
Can.Lasso(x1, y1, x2, y2);
CurDrag := NIL;
GlobalState := Idling;
end
else if CurDrag<>NIL then CurDrag.Drag(E.x, E.y);
end;
procedure HandleQShapes( E : Event);
var
r : rectangle;
fr : FRectangle;
el : Ellipse;
fe : FEllipse;
s : Shape;
x1, y1, x2, y2 : word;
begin
if E.typ = LBUTTONDOWN then begin
GlobalState := Creating;
CurDrag := BDrag;
Can.UnSelectAllObjects;
BDrag.Initialize( Size, E.x, E.y, E.x, E.y);
CurDrag.StartDrag( E.x, E.y);
end
else if (E.typ = LBUTTONUP) then begin
GlobalState := Idling;
CurDrag.EndDrag( E.x, E.y );
BDrag.GetRange(x1, y1, x2, y2);
CurDrag := NIL;
case GlobalShape of
Rect : begin
new(r);
s := r;
end;
FRect : begin
new(fr);
s := fr;
end;
Ell : begin
new(el);
s := el;
end;
FEll : begin
new(fe);
s := fe;
end;
end;
s.Initialize( x1, y1, x2-x1, y2-y1, CB.GetColor);
if Can.AddShape(s) then begin
s.Draw;
Can.SelectObject(s)
end
else Dispose(s);
end
else if CurDrag<>NIL then CurDrag.Drag( E.x, E.y);
end;
procedure HandleText( E : Event);
var
T : GText;
P : Prompter;
x1, y1, x2, y2 : word;
begin
if E.typ = LBUTTONDOWN then begin
GlobalState := Creating;
CurDrag := BDrag;
Can.UnSelectAllObjects;
BDrag.Initialize( Size, E.x, E.y, E.x, E.y);
CurDrag.StartDrag( E.x, E.y);
end
else if (E.typ = LBUTTONUP) then begin
GlobalState := Idling;
CurDrag.EndDrag( E.x, E.y );
BDrag.GetRange(x1, y1, x2, y2);
CurDrag := NIL;
new(P);
P.Initialize( 5, 15, 50,'Text:');
if P.Process then begin
new(T);
T.Initialize( x1, y1, x2-x1, y2-y1, CB.GetColor);
T.SetText(P.Response);
if Can.AddShape(T) then begin
T.Draw;
Can.SelectObject(T);
end
else
Dispose(T);
end;
Dispose(P);
end
else if CurDrag<>NIL then CurDrag.Drag( E.x, E.y);
end;
procedure HandleLine( E : Event);
var
l : Line;
x1, y1, x2, y2 : word;
begin
if E.typ = LBUTTONDOWN then begin
GlobalState := Creating;
Can.UnSelectAllObjects;
CurDrag := Drag;
CurDrag.StartDrag( E.x, E.y);
end
else if (E.typ = LBUTTONUP) then begin
GlobalState := Idling;
CurDrag.EndDrag( E.x, E.y );
Drag.GetRange(x1, y1, x2, y2);
CurDrag := NIL;
new(l);
l.Initialize( x1, y1, x2-x1, y2-y1, CB.GetColor);
if Can.AddShape(l) then begin
l.Draw;
Can.SelectObject(l);
end
else
Dispose(l);
end
else if CurDrag<>NIL then CurDrag.Drag( E.x, E.y);
end;
procedure ChoseSelector;
begin
GlobalShape := None;
MHandler := HandleSelector;
end;
procedure ChoseRectangle;
begin
GlobalShape := Rect;
MHandler := HandleQShapes;
end;
procedure ChoseFRectangle;
begin
GlobalShape := FRect;
MHandler := HandleQShapes;
end;
procedure ChoseEllipse;
begin
GlobalShape := Ell;
MHandler := HandleQShapes;
end;
procedure ChoseFEllipse;
begin
GlobalShape := FEll;
MHandler := HandleQShapes;
end;
procedure ChoseLine;
begin
GlobalShape := Lin;
MHandler := HandleLine;
end;
procedure ChoseText;
begin
GlobalShape := Txt;
MHandler := HandleText;
end;
procedure ChoseColors;
var
E : Event;
begin
GlobalShape := None;
CW.SelectItem(1);
ChoseSelector;
CW.Erase;
CB.Draw;
ShowPointer;
while TRUE do begin
GetEvent(E);
if (E.typ = LBUTTONUP) and
CB.PtInRegion( E.x, E.y) then begin
CB.Process( E.x, E.y);
HidePointer;
if Can.SelectedObject(NIL)=NIL then
ColorShape.color := CB.GetColor
else begin
Can.ChangeColor( CB.GetColor );
Can.Erase;
Can.Draw;
end;
CB.Erase;
CW.Draw;
exit;
end;
end;
end;
procedure ChoseDelete;
begin
GlobalShape := None;
Can.Delete;
Can.Erase;
Can.Draw;
CW.SelectItem(1);
ChoseSelector;
end;
procedure ChoseCopy;
begin
GlobalShape := None;
Can.Copy;
Can.Erase;
Can.Draw;
CW.SelectItem(1);
ChoseSelector;
end;
procedure ChoseRedraw;
begin
GlobalShape := None;
Can.Erase;
Can.Draw;
CW.SelectItem(1);
ChoseSelector;
end;
procedure ChoseFile;
var
E : Event;
begin
GlobalShape := None;
CW.SelectItem(1);
ChoseSelector;
CW.Erase;
FCW.Draw;
ShowPointer;
while TRUE do begin
GetEvent(E);
HidePointer;
{ Check if menu item. If so, let file command well do it }
if (E.typ=LBUTTONDOWN) and FCW.PtInRegion( E.x, E.y) then begin
repeat GetEvent(E) until E.typ=LBUTTONUP;
if FCW.PtInRegion( E.x, E.y) then FCW.Process( E.x, E.y);
{ now get out }
FCW.SelectItem(0);
FCW.Erase;
CW.Draw;
exit;
end;
ShowPointer;
end;
end;
procedure ChoseQuit;
begin
GlobalShape := None;
GlobalState := Done;
CW.SelectItem(1);
ChoseSelector;
end;
function GetFileName( var fn : string) : boolean;
var
p : Prompter;
begin
new(p);
p.Initialize( 5, 15, 40, 'Filename:');
GetFileName := p.Process;
fn := p.Response;
end;
procedure ChoseFNew;
begin
Can.SelectAllObjects;
Can.Delete;
Can.Erase;
{ Can.Draw; }
end;
procedure ChoseFOpen;
var
fn : string;
begin
if GetFileName(fn) then Can.Load(fn);
end;
procedure ChoseFSave;
var
fn : string;
begin
if GetFileName(fn) then Can.Save(fn);
end;
procedure ChoseFCancel;
begin
end;
{$F-}
procedure CreateCommWell;
const
NUMCOMMANDS = 13;
var
s : Selector;
r : Rectangle;
fr : FRectangle;
e : Ellipse;
fe : FEllipse;
l : Line;
t : GText;
begin
new(CW);
CW.Initialize( (vc.numypixels-1) div numcommands, MWIDTH, vc.numcolors-1);
new(s);
CW.AddCommand( s, ChoseSelector);
new(r);
CW.AddCommand( r, ChoseRectangle);
new(fr);
CW.AddCommand( fr, ChoseFRectangle);
new(e);
CW.AddCommand( e, ChoseEllipse);
new(fe);
CW.AddCommand( fe, ChoseFEllipse);
new(l);
CW.AddCommand( l, ChoseLine);
new(t);
CW.AddCommand( t, ChoseText );
t.SetText('Text');
t.SetHeight( cy );
new(ColorShape);
CW.AddCommand( ColorShape, ChoseColors );
ColorShape.SetText('Colors...');
ColorShape.SetHeight( cy );
new(t);
CW.AddCommand( t, ChoseDelete );
t.SetText('Delete');
t.SetHeight( cy );
new(t);
CW.AddCommand( t, ChoseCopy );
t.SetText('Copy');
t.SetHeight( cy );
new(t);
CW.AddCommand( t, ChoseRedraw );
t.SetText('Redraw');
t.SetHeight( cy );
new(t);
CW.AddCommand( t, ChoseFile);
t.SetText('File...');
t.SetHeight( cy );
new(t);
CW.AddCommand( t, ChoseQuit);
t.SetText('Quit');
t.SetHeight( cy );
CW.Draw;
CW.SelectItem(1);
CW.Menu[1].DoIt;
end;
procedure CreateFCommWell;
const
NUMCOMMANDS = 4;
var
t : GText;
begin
new(FCW);
FCW.Initialize( (vc.numypixels-1) div numcommands, MWIDTH, vc.numcolors-1);
new(t);
FCW.AddCommand( t, ChoseFNew );
t.SetText('New');
t.SetHeight( cy );
new(t);
FCW.AddCommand( t, ChoseFOpen );
t.SetText('Open...');
t.SetHeight( cy );
new(t);
FCW.AddCommand( t, ChoseFSave );
t.SetText('Save...');
t.SetHeight( cy );
new(t);
FCW.AddCommand( t, ChoseFCancel);
t.SetText('Cancel');
t.SetHeight( cy );
end;
procedure Initialize;
var
vidrows : Integer;
numfonts : integer;
begin
{ initialize CRT unit }
DirectVideo := FALSE;
{ initialize MSGraph unit }
vidrows := _SetVideoMode( _ERESCOLOR );
numfonts := _RegisterFonts( '*.fon');
_GetVideoConfig( vc );
{ initialize screen dependent parameters }
cx := vc.numxpixels div 80;
cy := vc.numypixels div 25;
{ initialize the event processor }
EnableEvents;
{ initialize canvas }
new(Can);
Can.Initialize( MWIDTH+1, 0, vc.numxpixels-1, vc.numypixels-1);
{ initialize command wells }
CreateCommWell;
CreateFCommWell;
{ initialize color bar }
new(CB);
CB.Initialize( (vc.numypixels-1) div vc.numcolors, MWIDTH, vc.numcolors);
{ Create Dragger objects }
new(Drag);
new(BDrag);
end;
procedure Finalize;
var
vidrows : Integer;
begin
DisableEvents;
vidrows := _SetVideoMode( _DEFAULTMODE );
end;
procedure ProcessEvents;
label
DoneWithEvent;
var
E : Event;
begin
CurDrag := NIL;
GlobalState := Idling;
while GlobalState<>Done do begin
GetEvent(E);
HidePointer;
{ Check if menu item. If so, let command well do it }
if (E.typ=LBUTTONDOWN) and CW.PtInRegion( E.x, E.y) then begin
repeat GetEvent(E) until E.typ=LBUTTONUP;
if CW.PtInRegion( E.x, E.y) then CW.Process( E.x, E.y);
end
else MHandler( E );
ShowPointer;
end; { while State<>done }
end;
begin
Initialize;
ProcessEvents;
Finalize;
end.